home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Runtime (.scm & .s) / _system.scm < prev    next >
Encoding:
Text File  |  1995-03-15  |  21.7 KB  |  776 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; System procedures
  6.  
  7. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8.  
  9. (define-system (##type x))
  10. (define-system (##type-cast x y))
  11. (define-system (##subtype x))
  12. (define-system (##subtype-set! x y))
  13.  
  14. (define-system (##unassigned? x)
  15.   (##eq? x ##unass-object))
  16.  
  17. (define-system (##unbound? x)
  18.   (##eq? x ##unbound-object))
  19.  
  20. (define-system (##fixnum? x)
  21.   (##eq? (##type x) (type-fixnum)))
  22.  
  23. (define-system (##special? x)
  24.   (##eq? (##type x) (type-special)))
  25.  
  26. (define-system (##subtyped? x)
  27.   (##eq? (##type x) (type-subtyped)))
  28.  
  29. (define-system (##placeholder? x)
  30.   (##eq? (##type x) (type-placeholder)))
  31.  
  32. (define-system (##ratnum? x)
  33.   (and (##subtyped? x)
  34.        (##eq? (##subtype x) (subtype-ratnum))))
  35.  
  36. (define-system (##cpxnum? x)
  37.   (and (##subtyped? x)
  38.        (##eq? (##subtype x) (subtype-cpxnum))))
  39.  
  40. (define-system (##bignum? x)
  41.   (and (##subtyped? x)
  42.        (##eq? (##subtype x) (subtype-bignum))))
  43.  
  44. (define-system (##flonum? x)
  45.   (and (##subtyped? x)
  46.        (##eq? (##subtype x) (subtype-flonum))))
  47.  
  48. (define-system (##vector-shrink! x y))
  49.  
  50. (define-system (##string-shrink! x y)
  51.   (##vector8-shrink x y))
  52.  
  53. (define-system (##make-vector8 x y)
  54.   (##make-string x (##type-cast y (type-special))))
  55.  
  56. (define-system (##vector8-length x)
  57.   (##string-length x))
  58.  
  59. (define-system (##vector8-ref x y)
  60.   (##type-cast (##string-ref x y) (type-fixnum)))
  61.  
  62. (define-system (##vector8-set! x y z)
  63.   (##string-set! x y (##type-cast z (type-special))))
  64.  
  65. (define-system (##vector8-shrink! x y)
  66.   (##string-shrink x y))
  67.  
  68. (define-system (##make-vector16 x y)
  69.   (let ((v (##make-vector8 (##fixnum.* x 2) 0)))
  70.     (let loop ((i (##fixnum.- x 1)))
  71.       (if (##not (##fixnum.< i 0))
  72.         (begin
  73.           (##vector16-set! v i y)
  74.           (loop (##fixnum.- i 1)))))
  75.     v))
  76.  
  77. (define-system (##vector16-length x)
  78.   (##fixnum.quotient (##vector8-length x) 2))
  79.  
  80. (define-system (##vector16-ref x y)
  81.   (let ((i (##fixnum.* y 2)))
  82.     (##fixnum.+ (##fixnum.* (##vector8-ref x i) 256)
  83.                 (##vector8-ref x (##fixnum.+ i 1)))))
  84.  
  85. (define-system (##vector16-set! x y z)
  86.   (let ((i (##fixnum.* y 2)))
  87.     (##vector8-set! x i (##fixnum.quotient z 256))
  88.     (##vector8-set! x (##fixnum.+ i 1) (##fixnum.modulo z 256))))
  89.  
  90. (define-system (##vector16-shrink! x y)
  91.   (##vector8-shrink x (##fixnum.* y 2)))
  92.  
  93. (define-system (##slot-ref x y))
  94.  
  95. (define-system (##slot-set! x y z))
  96.  
  97. (define-system (##pstate))
  98.  
  99. (define-system (##make-cell x)
  100.   (##cons x '()))
  101.  
  102. (define-system (##cell-ref x)
  103.   (##car x))
  104.  
  105. (define-system (##cell-set! x y)
  106.   (##set-car! x y))
  107.  
  108. (define-system (##touch x))
  109.  
  110. (define-system (##startup)
  111.   (let loop ((i 1))
  112.     (let ((ev ##exec-vector))
  113.       (let ((len (##vector-length ev)))
  114.         (if (##fixnum.< i len)
  115.           (if (##fixnum.= i (##fixnum.- len 1))
  116.             ((##vector-ref ev i))
  117.             (begin
  118.               ((##vector-ref ev i))
  119.               (loop (##fixnum.+ i 1)))))))))
  120.  
  121. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  122.  
  123. ; SPECIAL objects
  124.  
  125. (define ##undef-object   (##type-cast (data-undef)   (type-special)))
  126. (define ##unass-object   (##type-cast (data-unass)   (type-special)))
  127. (define ##unbound-object (##type-cast (data-unbound) (type-special)))
  128. (define ##eof-object     (##type-cast (data-eof)     (type-special)))
  129.  
  130. (define ##unprint-object ##undef-object)
  131.  
  132. (define (dylan-make sz)  ;;RL added for Dylan 8/24/93
  133.   (##dylan-make sz))
  134.  
  135. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  136.  
  137. ; Variants of standard procedures.
  138.  
  139. ; Most of these procedures do not touch their arguments and are mostly
  140. ; of fixed arity.
  141.  
  142. (define-system (##not x)
  143.   (if x #f #t))
  144.  
  145. ; ##eqv? is defined in "_numbers.scm"
  146.  
  147. (define-system (##eq? x y))
  148.  
  149. (define-system (##equal? x y touch?)
  150.  
  151.   (define (vector8=? x y)
  152.     (let ((len (##vector8-length x)))
  153.       (if (##eq? len (##vector8-length y))
  154.         (let loop ((i (##fixnum.- len 1)))
  155.           (cond ((##fixnum.< i 0)
  156.                  #t)
  157.                 ((##eq? (##vector8-ref x i) (##vector8-ref y i))
  158.                  (loop (##fixnum.- i 1)))
  159.                 (else
  160.                  #f)))
  161.         #f)))
  162.  
  163.   (define (equal x y)
  164.  
  165.     (define (vector=? x y)
  166.       (let ((len (##vector-length x)))
  167.         (if (##eq? len (##vector-length y))
  168.           (let loop ((i (##fixnum.- len 1)))
  169.             (cond ((##fixnum.< i 0)
  170.                   #t)
  171.                   ((equal (##vector-ref x i) (##vector-ref y i))
  172.                    (loop (##fixnum.- i 1)))
  173.                   (else
  174.                    #f)))
  175.           #f)))
  176.  
  177.     (cond ((##eq? x y)
  178.            #t)
  179.           ((##pair? x)
  180.            (and (##pair? y)
  181.                 (equal (##car x) (##car y))
  182.                 (equal (##cdr x) (##cdr y))))
  183.           ((##symbol? x)
  184.            #f)
  185.           ((##subtyped? x)
  186.            (and (##subtyped? y)
  187.                 (let ((tag (##subtype x)))
  188.                   (if (##eq? tag (##subtype y))
  189.                     (if (subtype-ovector? tag)
  190.                       (vector=? x y)
  191.                       (vector8=? x y))
  192.                     #f))))
  193.           (else
  194.            #f)))
  195.  
  196.   (define (equal* x y)
  197.  
  198.     (define (vector=? x y)
  199.       (let ((len (##vector-length x)))
  200.         (if (##eq? len (##vector-length y))
  201.           (let loop ((i (##fixnum.- len 1)))
  202.             (cond ((##fixnum.< i 0)
  203.                   #t)
  204.                   ((equal* (##vector-ref x i) (##vector-ref y i))
  205.                    (loop (##fixnum.- i 1)))
  206.                   (else
  207.                    #f)))
  208.           #f)))
  209.  
  210.     (let ((x (##touch x)) (y (##touch y)))
  211.       (cond ((##eq? x y)
  212.              #t)
  213.             ((##pair? x)
  214.              (and (##pair? y)
  215.                   (equal* (##car x) (##car y))
  216.                   (equal* (##cdr x) (##cdr y))))
  217.             ((##symbol? x)
  218.              #f)
  219.             ((##subtyped? x)
  220.              (and (##subtyped? y)
  221.                   (let ((tag (##subtype x)))
  222.                     (if (##eq? tag (##subtype y))
  223.                       (if (subtype-ovector? tag)
  224.                         (vector=? x y)
  225.                         (vector8=? x y))
  226.                       #f))))
  227.             (else
  228.              #f))))
  229.  
  230.   (if touch?
  231.     (equal* x y)
  232.     (equal x y)))
  233.  
  234. (define-system (##pair? x))
  235.  
  236. (define-system (##cons x y))
  237.  
  238. (define-system (##set-car! x y))
  239.  
  240. (define-system (##set-cdr! x y))
  241.  
  242. (define-system (##car x))
  243.  
  244. (define-system (##cdr x))
  245.  
  246. (##define-macro (define-c...r name pattern)
  247.  
  248.   (define (gen name pattern)
  249.     (if (<= pattern 3)
  250.        (if (= pattern 3) '(##CDR X) '(##CAR X))
  251.        (let ((x (gen name (quotient pattern 2))))
  252.          (if (odd? pattern) '(##CDR ,x) '(##CAR ,x)))))
  253.  
  254.   `(DEFINE-SYSTEM (,name X)
  255.      ,(gen name pattern)))
  256.  
  257. (define-c...r ##caar 4)
  258. (define-c...r ##cadr 5)
  259. (define-c...r ##cdar 6)
  260. (define-c...r ##cddr 7)
  261. (define-c...r ##caaar 8)
  262. (define-c...r ##caadr 9)
  263. (define-c...r ##cadar 10)
  264. (define-c...r ##caddr 11)
  265. (define-c...r ##cdaar 12)
  266. (define-c...r ##cdadr 13)
  267. (define-c...r ##cddar 14)
  268. (define-c...r ##cdddr 15)
  269. (define-c...r ##caaaar 16)
  270. (define-c...r ##caaadr 17)
  271. (define-c...r ##caadar 18)
  272. (define-c...r ##caaddr 19)
  273. (define-c...r ##cadaar 20)
  274. (define-c...r ##cadadr 21)
  275. (define-c...r ##caddar 22)
  276. (define-c...r ##cadddr 23)
  277. (define-c...r ##cdaaar 24)
  278. (define-c...r ##cdaadr 25)
  279. (define-c...r ##cdadar 26)
  280. (define-c...r ##cdaddr 27)
  281. (define-c...r ##cddaar 28)
  282. (define-c...r ##cddadr 29)
  283. (define-c...r ##cdddar 30)
  284. (define-c...r ##cddddr 31)
  285.  
  286. (define-system (##weak-pair? x))
  287. (define-system (##weak-cons x y))
  288. (define-system (##weak-set-car! x y))
  289. (define-system (##weak-set-cdr! x y))
  290. (define-system (##weak-car x))
  291. (define-system (##weak-cdr x))
  292.  
  293. (define-system (##null? x)
  294.   (##eq? x '()))
  295.  
  296. (define-system (##list . l)
  297.   l)
  298.  
  299. (define-system (##length l)
  300.   (let loop ((l l) (n 0))
  301.     (if (##pair? l)
  302.       (loop (##cdr l) (##fixnum.+ n 1))
  303.       n)))
  304.  
  305. (define-system (##append l1 l2)
  306.   (if (##pair? l1)
  307.     (let ((result (##cons (##car l1) '())))
  308.       (##set-cdr!
  309.         (let loop ((end result) (l1 (##cdr l1)))
  310.           (if (##pair? l1)
  311.             (let ((tail (##cons (##car l1) '())))
  312.               (##set-cdr! end tail)
  313.               (loop tail (##cdr l1)))
  314.             end))
  315.         l2)
  316.       result)
  317.     l2))
  318.  
  319. (define-system (##reverse l)
  320.   (let loop ((l l) (x '()))
  321.     (if (##pair? l)
  322.       (loop (##cdr l) (##cons (##car l) x))
  323.       x)))
  324.  
  325. (define-system (##memq x l)
  326.   (let loop ((l l))
  327.     (if (##pair? l)
  328.       (if (##eq? x (##car l))
  329.         l
  330.         (loop (##cdr l)))
  331.       #f)))
  332.  
  333. (define-system (##assq x l)
  334.   (let loop ((y l))
  335.     (if (##pair? y)
  336.       (let ((couple (##car y)))
  337.         (if (##eq? x (##car couple))
  338.           couple
  339.           (loop (##cdr y))))
  340.         #f)))
  341.  
  342. (define-system (##symbol? x)
  343.   (and (##subtyped? x)
  344.        (##eq? (##subtype x) (subtype-symbol))))
  345.  
  346. (define-system (##symbol->string sym)
  347.   (symbol-string sym))
  348.  
  349. (define-system (##string->symbol str)
  350.  
  351.   (define (hash str n)
  352.     (let ((len (##string-length str)))
  353.       (let loop ((h 0) (i 0))
  354.         (if (##not (##fixnum.< i len))
  355.           h
  356.           (let ((x (##fixnum.+ (##fixnum.* h 256)
  357.                                (##type-cast (##string-ref str i)
  358.                                             (type-fixnum)))))
  359.             (loop (##fixnum.remainder x n) (##fixnum.+ i 1)))))))
  360.  
  361.   (let ((h (hash str (##vector-length ##symbol-table))))
  362.     (let loop ((l (##vector-ref ##symbol-table h)))
  363.       (cond ((##not (##pair? l))
  364.              (let ((sym (symbol-make (##string-copy str))))
  365.                (##vector-set! ##symbol-table h
  366.                  (##cons sym (##vector-ref ##symbol-table h)))
  367.                sym))
  368.             ((##string=? (symbol-string (##car l)) str)
  369.              (##car l))
  370.             (else
  371.              (loop (##cdr l)))))))
  372.  
  373. (define-system (##string->uninterned-symbol str)
  374.   (symbol-make (##string-copy str)))
  375.  
  376. ; numeric procedures are in "_numbers.scm"
  377.  
  378. (define-system (##char? x)
  379.   (and (##eq? (##type x) (type-special))
  380.        (let ((y (##type-cast x (type-fixnum))))
  381.          (and (##fixnum.< 0 y) (##fixnum.< y (char-range))))))
  382.  
  383. (define-nary0-boolean (##char=? x y)
  384.   (##eq? x y) no-check no-touch)
  385.  
  386. (define-nary0-boolean (##char<? x y)
  387.   (##char<? x y) no-check no-touch)
  388.  
  389. (define-nary0-boolean (##char>? x y)
  390.   (##char<? y x) no-check no-touch)
  391.  
  392. (define-nary0-boolean (##char<=? x y)
  393.   (##not (##char<? y x)) no-check no-touch)
  394.  
  395. (define-nary0-boolean (##char>=? x y)
  396.   (##not (##char<? x y)) no-check no-touch)
  397.  
  398. (define-nary0-boolean (##char-ci=? x y)
  399.   (##char=? (##char-downcase x) (##char-downcase y)) no-check no-touch)
  400.  
  401. (define-nary0-boolean (##char-ci<? x y)
  402.   (##char<? (##char-downcase x) (##char-downcase y)) no-check no-touch)
  403.  
  404. (define-nary0-boolean (##char-ci>? x y)
  405.   (##char<? (##char-downcase y) (##char-downcase x)) no-check no-touch)
  406.  
  407. (define-nary0-boolean (##char-ci<=? x y)
  408.   (##not (##char<? (##char-downcase y) (##char-downcase x))) no-check no-touch)
  409.  
  410. (define-nary0-boolean (##char-ci>=? x y)
  411.   (##not (##char<? (##char-downcase x) (##char-downcase y))) no-check no-touch)
  412.  
  413. (define-system (##char-alphabetic? c)
  414.   (let ((x (##char-downcase c)))
  415.     (and (##not (##char<? x #\a)) (##not (##char<? #\z x)))))
  416.  
  417. (define-system (##char-numeric? c)
  418.   (and (##not (##char<? c #\0)) (##not (##char<? #\9 c))))
  419.  
  420. (define-system (##char-whitespace? c)
  421.   (char-whitespace c))
  422.  
  423. (define-system (##char-upper-case? c)
  424.   (and (##not (##char<? c #\A)) (##not (##char<? #\Z c))))
  425.  
  426. (define-system (##char-lower-case? c)
  427.   (and (##not (##char<? c #\a)) (##not (##char<? #\z c))))
  428.  
  429. (define-system (##char->integer c)
  430.   (##type-cast c (type-fixnum)))
  431.  
  432. (define-system (##integer->char n)
  433.   (##type-cast n (type-special)))
  434.  
  435. (define-system (##char-upcase c)
  436.   (if (and (##not (##char<? c #\a)) (##not (##char<? #\z c)))
  437.     (##type-cast (##fixnum.- (##type-cast c (type-fixnum)) (char-up-to-down))
  438.                  (type-special))
  439.     c))
  440.  
  441. (define-system (##char-downcase c)
  442.   (if (and (##not (##char<? c #\A)) (##not (##char<? #\Z c)))
  443.     (##type-cast (##fixnum.+ (##type-cast c (type-fixnum)) (char-up-to-down))
  444.                  (type-special))
  445.     c))
  446.  
  447. (define-system (##string? x)
  448.   (and (##subtyped? x)
  449.        (##eq? (##subtype x) (subtype-string))))
  450.  
  451. (define-system (##make-string x y)
  452.   (##make-vector8 x (##type-cast y (type-fixnum))))
  453.  
  454. (define-system (##string-length str)
  455.   (##vector8-length str))
  456.  
  457. (define-system (##string-ref str i)
  458.   (##type-cast (##vector8-ref str i) (type-special)))
  459.  
  460. (define-system (##string-set! str i c)
  461.   (##vector8-set! str i (##type-cast c (type-fixnum))))
  462.  
  463. (define-system (##string=? x y)
  464.   (let ((len (##string-length x)))
  465.     (if (##eq? len (##string-length y))
  466.       (let loop ((i (##fixnum.- len 1)))
  467.         (cond ((##fixnum.< i 0)
  468.                #t)
  469.               ((##char=? (##string-ref x i) (##string-ref y i))
  470.                (loop (##fixnum.- i 1)))
  471.               (else
  472.                #f)))
  473.       #f)))
  474.  
  475. (define-system (##string<? x y)
  476.   (let ((lx (##string-length x))
  477.         (ly (##string-length y)))
  478.     (let ((n (if (##fixnum.< lx ly) lx ly)))
  479.       (let loop ((i 0))
  480.         (if (##fixnum.< i n)
  481.           (let ((cx (##string-ref x i))
  482.                 (cy (##string-ref y i)))
  483.             (if (##char=? cx cy)
  484.               (loop (##fixnum.+ i 1))
  485.               (##char<? cx cy)))
  486.           (##fixnum.< n ly))))))
  487.  
  488. (define-system (##string>? x y)
  489.   (##string<? y x))
  490.  
  491. (define-system (##string<=? x y)
  492.   (##not (##string<? y x)))
  493.  
  494. (define-system (##string>=? x y)
  495.   (##not (##string<? x y)))
  496.  
  497. (define-system (##string-ci=? x y)
  498.   (let ((len (##string-length x)))
  499.     (if (##eq? len (##string-length y))
  500.       (let loop ((i (##fixnum.- len 1)))
  501.         (cond ((##fixnum.< i 0)
  502.                #t)
  503.               ((##char=? (##char-downcase (##string-ref x i))
  504.                          (##char-downcase (##string-ref y i)))
  505.                (loop (##fixnum.- i 1)))
  506.               (else
  507.                #f)))
  508.       #f)))
  509.  
  510. (define-system (##string-ci<? x y)
  511.   (let ((lx (##string-length x))
  512.         (ly (##string-length y)))
  513.     (let ((n (if (##fixnum.< lx ly) lx ly)))
  514.       (let loop ((i 0))
  515.         (if (##fixnum.< i n)
  516.           (let ((cx (##char-downcase (##string-ref x i)))
  517.                 (cy (##char-downcase (##string-ref y i))))
  518.             (if (##char=? cx cy)
  519.               (loop (##fixnum.+ i 1))
  520.               (##char<? cx cy)))
  521.           (##fixnum.< n ly))))))
  522.  
  523. (define-system (##string-ci>? x y)
  524.   (##string-ci<? y x))
  525.  
  526. (define-system (##string-ci<=? x y)
  527.   (##not (##string-ci<? y x)))
  528.  
  529. (define-system (##string-ci>=? x y)
  530.   (##not (##string-ci<? x y)))
  531.  
  532. (define-system (##substring x y z)
  533.   (let* ((n (##fixnum.- z y))
  534.          (result (##make-string n #\space)))
  535.     (let loop ((i (##fixnum.- n 1)))
  536.       (if (##not (##fixnum.< i 0))
  537.         (begin
  538.           (##string-set! result i (##string-ref x (##fixnum.+ y i)))
  539.           (loop (##fixnum.- i 1)))))
  540.     result))
  541.  
  542. (define-system (##string-append . l)
  543.   (let loop1 ((n 0) (x l) (y '()))
  544.     (if (##pair? x)
  545.       (let ((s (##car x)))
  546.         (loop1 (##fixnum.+ n (##string-length s)) (##cdr x) (##cons s y)))
  547.       (let ((result (##make-string n #\space)))
  548.         (let loop2 ((k (##fixnum.- n 1)) (y y))
  549.           (if (##pair? y)
  550.             (let ((s (##car y)))
  551.               (let loop3 ((i k) (j (##fixnum.- (##string-length s) 1)))
  552.                 (if (##not (##fixnum.< j 0))
  553.                   (begin
  554.                     (##string-set! result i (##string-ref s j))
  555.                     (loop3 (##fixnum.- i 1) (##fixnum.- j 1)))
  556.                   (loop2 i (##cdr y)))))
  557.             result))))))
  558.  
  559. (define-system (##vector? x)
  560.   (and (##subtyped? x)
  561.        (or (##eq? (##subtype x) (subtype-vector))
  562.            (##eq? (##subtype x) (subtype-dylan))))) ;;added for Dylan (RL)
  563.  
  564. (define-system (##make-vector x y))
  565.  
  566. (define-system (##vector-length vect))
  567.  
  568. (define-system (##vector-ref str i))
  569.  
  570. (define-system (##vector-set! str i c))
  571.  
  572. (define-system (##procedure? x)
  573.   (##eq? (##type x) (type-procedure)))
  574.  
  575. (define-system (##apply p l))
  576.  
  577. (define-system (##call-with-current-continuation p))
  578.  
  579. ; input/output procedures are in "ports.scm"
  580.  
  581. (define-system (##string-copy str)
  582.   (let* ((n (##string-length str))
  583.          (result (##make-string n #\space)))
  584.     (let loop ((i (##fixnum.- n 1)))
  585.       (if (##fixnum.< i 0)
  586.         result
  587.         (begin
  588.           (##string-set! result i (##string-ref str i))
  589.           (loop (##fixnum.- i 1)))))))
  590.  
  591. (define-system (##vector->list vect)
  592.   (let loop ((l '()) (i (##fixnum.- (##vector-length vect) 1)))
  593.     (if (##fixnum.< i 0)
  594.       l
  595.       (loop (##cons (##vector-ref vect i) l) (##fixnum.- i 1)))))
  596.  
  597. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  598.  
  599. ; Procedures for front end
  600.  
  601. (define-system (##quasi-append x y)
  602.   (touch-vars (x)
  603.     (if (##pair? x)
  604.       (let ((result (##cons (##car x) '())))
  605.         (##set-cdr!
  606.           (let loop ((end result) (x (##cdr x)))
  607.             (touch-vars (x)
  608.               (if (##pair? x)
  609.                 (let ((tail (##cons (##car x) '())))
  610.                   (##set-cdr! end tail)
  611.                   (loop tail (##cdr x)))
  612.                 end)))
  613.           y)
  614.         result)
  615.       y)))
  616.  
  617. (define-system (##quasi-list . l)
  618.   l)
  619.  
  620. (define-system (##quasi-cons x y)
  621.   (##cons x y))
  622.  
  623. (define-system (##quasi-list->vector l)
  624.   (let loop1 ((x l) (n 0))
  625.     (touch-vars (x)
  626.       (if (##pair? x)
  627.         (loop1 (##cdr x) (##fixnum.+ n 1))
  628.         (let ((vect (##make-vector n #f)))
  629.           (let loop2 ((x l) (i 0))
  630.             (touch-vars (x)
  631.               (if (##pair? x)
  632.                 (begin
  633.                   (##vector-set! vect i (##car x))
  634.                   (loop2 (##cdr x) (##fixnum.+ i 1)))
  635.                 vect))))))))
  636.  
  637. (define-system (##case-memv x l)
  638.   (touch-vars (x)
  639.     (let loop ((l l))
  640.       (if (##pair? l)
  641.         (if (##eqv? x (##car l))
  642.           l
  643.           (loop (##cdr l)))
  644.         #f))))
  645.  
  646. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  647.  
  648. ; Global variables
  649.  
  650. (define-system (##global-var sym))
  651.  
  652. (define-system (##global-var-ref ind))
  653.  
  654. (define-system (##global-var-set! ind val))
  655.  
  656. (define (##object->global-var-name val)
  657.   (let loop ((ind 0))
  658.     (if (##fixnum.< ind ##global-var-count)
  659.       (if (##eq? (##global-var-ref ind) val)
  660.         (##index->global-var-name ind)
  661.         (loop (##fixnum.+ ind 1)))
  662.       #f)))
  663.  
  664. (define (##index->global-var-name ind)
  665.   (let loop1 ((i (##fixnum.- (##vector-length ##symbol-table) 1)))
  666.     (if (##fixnum.< i 0)
  667.       #f
  668.       (let loop2 ((l (##vector-ref ##symbol-table i)))
  669.         (if (##null? l)
  670.           (loop1 (##fixnum.- i 1))
  671.           (let ((sym (##car l)))
  672.             (if (##eq? ind (symbol-glob-var sym))
  673.               sym
  674.               (loop2 (##cdr l)))))))))
  675.  
  676. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  677.  
  678. ; Dynamic environment stuff:
  679.  
  680. (define ##dynamic-global-env '())
  681.  
  682. (define-system (##dynamic-define name (val))
  683.   (let ((env ##dynamic-global-env))
  684.     (let loop ((l env))
  685.       (if (##pair? l)
  686.         (let ((couple (##car l)))
  687.           (if (##eq? (##car couple) name)
  688.             (begin (##set-cdr! couple val) ##undef-object)
  689.             (loop (##cdr l))))
  690.         (set! ##dynamic-global-env
  691.           (##cons (##cons name (if (##unassigned? val) ##undef-object val))
  692.                   env))))))
  693.  
  694. (define-system (##dynamic-ref name (default))
  695.   (let loop1 ((l1 (##dynamic-env-ref)))
  696.     (cond ((##pair? l1)
  697.            (let loop2 ((l2 (##car l1)))
  698.              (if (##pair? l2)
  699.                (let ((couple (##car l2)))
  700.                  (if (##eq? (##car couple) name)
  701.                    (##cdr couple)
  702.                    (loop2 (##cdr l2))))
  703.                (loop1 (##cdr l1)))))
  704.           (else
  705.            (let loop3 ((l3 ##dynamic-global-env))
  706.              (if (##pair? l3)
  707.                (let ((couple (##car l3)))
  708.                  (if (##eq? (##car couple) name)
  709.                    (##cdr couple)
  710.                    (loop3 (##cdr l3))))
  711.                (if (##unassigned? default)
  712.                  (##signal '##SIGNAL.UNBOUND-DYNAMIC-VAR name)
  713.                  default)))))))
  714.  
  715. (define-system (##dynamic-set! name val)
  716.   (let loop1 ((l1 (##dynamic-env-ref)))
  717.     (cond ((##pair? l1)
  718.            (let loop2 ((l2 (##car l1)))
  719.              (if (##pair? l2)
  720.                (let ((couple (##car l2)))
  721.                  (if (##eq? (##car couple) name)
  722.                    (begin (##set-cdr! couple val) ##undef-object)
  723.                    (loop2 (##cdr l2))))
  724.                (loop1 (##cdr l1)))))
  725.           (else
  726.            (let loop3 ((l3 ##dynamic-global-env))
  727.              (if (##pair? l3)
  728.                (let ((couple (##car l3)))
  729.                  (if (##eq? (##car couple) name)
  730.                    (begin (##set-cdr! couple val) ##undef-object)
  731.                    (loop3 (##cdr l3))))
  732.                (##signal '##SIGNAL.UNBOUND-DYNAMIC-VAR name)))))))
  733.  
  734. (define-system (##dynamic-bind bindings thunk)
  735.   (let ((env (##dynamic-env-ref)))
  736.     (##dynamic-env-bind (##cons bindings env) thunk)))
  737.  
  738. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  739.  
  740. ; Benchmarking stuff
  741.  
  742. (define-system (##benchmark thunk)
  743.   (let ((buf1 (##make-vector 2 0))
  744.         (buf2 (##make-vector 2 0)))
  745.     (##cpu-times buf1)
  746.     (let ((real1 (##real-time)))
  747.       (let ((result (thunk)))
  748.         (let ((real2 (##real-time)))
  749.           (##cpu-times buf2)
  750.           (##list
  751.             (##fixnum.- (##vector-ref buf2 0) (##vector-ref buf1 0))
  752.             (##fixnum.- (##vector-ref buf2 1) (##vector-ref buf1 1))
  753.             (##fixnum.- real2 real1)
  754.             result))))))
  755.  
  756. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  757.  
  758. ; Jobs
  759.  
  760. (define (##make-jobs)
  761.   (##make-queue))
  762.  
  763. (define (##add-job jobs h)
  764.   (##queue-put! jobs h))
  765.  
  766. (define (##invoke-jobs jobs)
  767.   (if (and (##subtyped? jobs)
  768.            (##eq? (##subtype jobs) (subtype-queue)))
  769.     (let loop ((lst (##queue-peek-list jobs)))
  770.       (if (##pair? lst)
  771.         (begin
  772.           ((##car lst))
  773.           (loop (##cdr lst)))))))
  774.  
  775. ;------------------------------------------------------------------------------
  776.